00100	C  SUBRS. VLINE, ASKIT, GRED, LPEN, DELETE, DPYNEW, PLTCMD
00200	C*****  SAVIT, LISTP, FIXUP  ***************
00300	
00400	
00500		SUBROUTINE VLINE(R3,R4,R5,R6)
00600		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
00700	6	TYPE 3
00800		ACCEPT F78F,R3,R4,R5,R6
00900		REREAD FA1,ASK
01000		IF(ASK.EQ.'B')R3=99
01005	C  99 IS ALSO USED IN MOVER.F4
01010		IF(R3.GE.99)RETURN
01100		IF(ASK.NE.'L')GO TO 66
01200	C  TYPE 'L' FOR LIGHT-PEN
01300		K=-1
01400	67	R4=RY
01500		CALL LPEN(R3,RY,RX)
01520		REREAD FA1,ASK
01560		IF(ASK.EQ.'B')R3=99
01600		IF(R3.GE.99)RETURN
01700		K=-K
01800		IF(K.GT.0)GO TO 67
01900		R5=RY
02000	C LIGHT PEN IS READ TWICE
02100	66	ASK=-1
02200		IF(R6.LT.100)GO TO 1
02300		R6=R6-100
02400	C  FOR 'ASK' ADD 100 TO PARAM NUMBER GIVEN.
02500		ASK=0
02600	1	CALL BOX(-1,R4)
02700		CALL BOX(-2,R5)
02800	C  PUTS UP TWO VERTICAL LINES
02900	3	FORMAT(' TYPE STAFF #, POS1, POS2 AND CODE #  '$)
03000		END
03100	
03200		SUBROUTINE ASKIT
03300		COMMON /DPY/ST(4000),WDS(250),MEDIT,IGO
03400		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
03500		COMMON /XRN/RN(2000) /KJY/ K,JY
03600		IGO=0
03700		CALL DPYNEW
03800		X=ST(2)
03900		CALL BOX(JY,RN(JY+2))
04000		ST(2)=X
04100		TYPE 1
04200		ACCEPT FA1,K
04300		IF(K.EQ.'G')ASK=-1
04400		CALL DPYNEW
04500		IGO=1
04600	1	FORMAT(' N=NO, <CR>=YES, G=GO  '$)
04700		END
04800	
04900		SUBROUTINE GRED
04950		INTEGER PWDS
05000		COMMON /DPY/IST(4000),IWDS(250),MEDIT,IGO
05100		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /KJY/ K,JY
05200		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
05300		COMMON R2,JA,J,J2,RJQ(6),RC,IZ,RX,KV,RY,IA,IB,C,D,JZ,A,
05400		1 NX,VY,RB,JQ(20) /XRN/RN(2000) /ALF/INP(72),ML
05500		COMMON /PTR/PWDS(250),ITEM,L,I,IX/POSI/STFF(8),JJB,POS
05600		COMMON/RINP/R(10,80),RPOS(100)
05700	
05800		EQUIVALENCE (IST2,IST(2))
05900		RC=999
06000		RSTF=RC
06100	CC **CAN'T GET HERE ***IF(INP(1).NE.'A'.AND.INP(1).NE.'D')GO TO 1
06200	C  LEAVES ROUTINE
06300	7	CALL VLINE(R2,Z,POS,RX)
06400	C  PUTS UP TWO VERTICAL LINES
06520		REREAD FA1,NX
06560		IF(NX.EQ.'B')GO TO 170
06570		IF(R2.LT.99)GO TO 70
06600	170	JA=98
06700		RETURN
06800	70	IF(POS.EQ.0)POS=200
06900	C  0,0  DOES WHOLE STAFF
07000		IF(INP(1).NE.'A')GO TO 4
07100		TYPE 55
07200		ACCEPT F78F,V
07300		REREAD FA1,K
07400	C  TYPE 'L' FOR LIGHT PEN
07500		IF(V(1).EQ.99)GO TO 7
07510		IF(K.EQ.'B')GO TO 7
07550	C TYPE 'B' OR 99 TO BACKUP
07600		IF(K.NE.'L')GO TO 66
07700		DO 67 K=1,2
07800		V(2)=RY
07900		CALL LPEN(V(1),RY,RX)
07910		REREAD FA1,JA
07920		IF(JA.EQ.'B')GO TO 7
08000	67	IF(V(1).GE.99)GO TO 7
08100		V(3)=RY
08200	66	JA=0
08300		IZ=0
08400	C  COUNTER
08500		GO TO 14
08600	4	JA=98
08700	C  FOR DELETIONS
08800	C  STF.N, -99    -- DELETES ALL BUT STAFF N.
08900		IF(Z.NE.-99)GO TO 14
09000		RSTF=R2
09100		R2=99
09200	14	NX=0
09300	C  LOOP STARTS HERE
09400		J=0
09500	140	NX=NX+1
09600	142	JY=PWDS(NX)
09700		RB=RN(JY+3)
09800		IF(RTLINE(JY))GO TO 6
09900		IF(RB.LT.Z)GO TO 6
10000		IF(RB.GT.POS)GO TO 6
10100		IF(RN(JY+2).EQ.RSTF)GO TO 6
10200	C  FOR -99 DELETES.
10300		RB=RN(JY+1)
10400		IF(V(1).EQ.12)GO TO 77
10410		IF(V(1).EQ.100)GO TO 341
10420	C USE P100 AND ANY CODE# TO CREATE CUES. I.E. MINI NOTES, RESTS, BEAMS.
10500		IF(RC.EQ.999)GO TO 143
10600	C  USE P12 TO INVERT STEM, BEAM AND SLURS ALL AT ONCE.
10700	C  SET 12 TO 1 WITH CODE 5 TO INVERT SLURS ONLY
10800	77	RC=0
10900		IF(RB.EQ.5)GO TO 141
11000		IF(RB.NE.6)GO TO 143
11100		IF(RX.EQ.1)GO TO 141
11200	143	IF(RB.NE.RX.AND.RX.NE.0)GO TO 6
11300		IF(ASK)GO TO 100
11400		CALL ASKIT
11500		IF(K.EQ.'N')GO TO 6
11600		IF(K.EQ.'X')GO TO 19
11700	100	IF(INP(1).EQ.'A')GO TO 141
11800		IF(J)GO TO 40
11900		J=-1
12000		K=NX
12100	41	IZ=NX
12200		IF(NX.LT.ITEM)GO TO 140
12300	40	IF(NX-IZ.EQ.1)GO TO 41
12400	C  GO BACK FOR MORE - IF IN RIGHT ORDER.
12500	C  RANGE TO DEL. = K→NX
12600	45	J=IZ+1
12700		IA=PWDS(K)
12800		IB=PWDS(J)-IA
12900		JZ=IWDS(K)
13000		J2=IWDS(J)-JZ
13100		J=J-K
13200		ITEM=ITEM-J
13300		DO 42 IZ=K,ITEM+1
13400		PWDS(IZ)=PWDS(IZ+J)-IB
13500	42	IWDS(IZ)=IWDS(IZ+J)-J2
13600		IST2=IST2-J2
13800		I=I-IB
14000		 CALL LOOP(IA,I,1,0,IB,RN)
14100		CALL LOOP(JZ+2,IST2+2,1,0,J2,IST)
14200		IF(K.GE.ITEM)GO TO 1
14300	C  EXITS
14400		NX=K+1
14500		GO TO 142
14510	341	IF(RB.EQ.6)GO TO 141
14520		IF(RB.GT.2)GO TO 6
14600	141	IF(IZ.GE.97)GO TO 9
14700	C   THERE'S A LIMIT TO THE R ARRAY    4/18/73
14800		IZ=IZ+1
14900	C  FOUND AN ITEM
15000		R(1,IZ)=22
15100		R(2,IZ)=NX
15200	10	IZ=IZ+1
15300		DO 101 KV=3,10
15400	101	R(KV,IZ)=0
15410		IF(V(1).NE.100)GO TO 131
15450	231	R(1,IZ)=400
15455	C  MAKES MINI NOTES, RESTS, BEAMS
15460		R(2,IZ)=100
15470		GO TO 6
15500	131	IF(RC.EQ.999)GO TO 11
15600		IF(RB.EQ.1)GO TO 30
15700	31	RC=RN(JY+7)
15800		IF(RB.EQ.6)GO TO 32
15900	C  NEXT INVERTS DIP
16000		IF(RX.EQ.1)GO TO 35
16100		A=-1.6
16200		RB=-10
16300		IF(RC)A=-A
16400	36	R(7,IZ)=2
16500		R(8,IZ)=RN(JY+2)+A
16600		GO TO 37
16700	35	RB=-4
16800		IF(RN(JY+8).LT.-1)RB=-1.4
16900	C  2 AND .7 ARE HGTS SET IN 'BEAMS'
17000	37	IF(RC)RB=-RB
17100		R(3,IZ)=4
17200		R(4,IZ)=RN(JY+4)+RB
17300		R(6,IZ)=RN(JY+5)+RB
17400		R(5,IZ)=5
17500	33	R(1,IZ)=7
17600		R(2,IZ)=-RC
17700		GO TO 6
17800	32	IF(RC.LT.20)GO TO 34
17900	C  THIS IS FOR BEAMS
18000	232	RC=10-RC
18100		GO TO 33
18200	132	IF(RC.GT.-20)GO TO 232
18300		GO TO 332
18400	34	IF(RC)GO TO 132
18500	C  P7 IS NEG FOR TREMOLOS
18600	332	RC=-10-RC
18700		GO TO 33
18800	
18900	C  NEXT INVERTS STEMS EITHER WAY. USE ANY #>11 WITH CODE 1 TO INVERT.
19000	C  MUST! BE FIRST IN LIST!!!
19100	C	RC=0
19200	30	RB=RN(JY+5)
19300		IF(RB.LT.10)GO TO 12
19400	C  NO STEM < 10
19500		RC=10
19600		IF(RB.GE.20)RC=-RC
19700		RB=RB+RC
19800	12	V(1)=5.
19900		V(2)=RB
20000	C  SO IT WILL DISPLAY RESULT
20100	11	DO 8 K=1,10
20200	8	R(K,IZ)=V(K)
20300	6	IF(J)GO TO 45
20400		IF(NX.LT.ITEM)GO TO 140
20500	19	IF(INP(1).NE.'A')GO TO 1
20600	9	R(1,IZ+1)=222
20700		R(1,IZ+2)=0
20800	CC	REND=-1.
20900	1	CALL HYDPOG(3)
21000	55	FORMAT(' TYPE',3(' P#, CHNG ')/)
21100		END
21200	
21300		SUBROUTINE LPEN(A,B,C)
21400		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /SIZ/RSZ,JCEN,KCEN
21500		COMMON /POSI/STFF(8),JJ2,POS /ALF/INP(71),M,L /C/MM,LL
21600	CC5	CALL SETCUR(0,100,0)
21610		M=MM
21620		L=LL
21650		IF(IABS(M).GT.512)GO TO 4
21660		IF(IABS(L).LE.512)GO TO 3
21670	4	M=0
21675		L=100
21680	3	CALL SETCUR(M,L,0)
21700		TYPE 17
21800		ACCEPT FA1,D
21900		IF(D.EQ.'9')RETURN
22000		IF(D.EQ.'X')RETURN
22100	C  TYPE 'B' OR 99 TO BACK UP
22110		IF(D.EQ.'B')RETURN
22200		CALL RDCUR(M,L)
22300	CC	CALL CLRCUR
22400		L=(L+KCEN)/RSZ
22500	1	B=((M+JCEN)/RSZ+596.0)/5.96
22600	C  B=HORIZ. STEP NUM.
22700		DO 13 K=1,8
22800		M=STFF(K)+60.
22900		IF(L.GT.M)GO TO 13
23000		A=K-4
23100	C  A=STAFF NUM.
23200		GO TO 8
23300	13	CONTINUE
23400	17	FORMAT(' TYPE <CR> TO SET POINT'/)
23500	8	C=IFIX((L-STFF(K)+21.)/7.+.5)
23600	C  FINDS VERT. NOTE NUM.
23700		TYPE F78F,A,B
23800		END
23900	
24000	
24100	
24200	CC	SUBROUTINE DELETE
24300	CC	IMPLICIT INTEGER(A-Q,S-Z)
24500	CC	COMMON/DL/X22,SAVER,NAME
24600	CC	COMMON /XRN/RN(4000)
24700	CC	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(15),R6,DEL,X,JY,K
24800	CC	COMMON/PTR/PWDS(250),ITEM,L,I,IX
24900	CC	COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
25000	CC	EQUIVALENCE (ST2,ST(2))
25100	
25200	CC1	X=ITEM
25300	CC171	IX=I
25400	CC	L=RN(MEDIT)+3.0
25500	C  SIZE OF DELETION
25600	CC	I=IX-L
25700	CC	CALL LOOP(MEDIT,I,1,0,L,RN)
25800	CC	JY=WDS(X22+1)-WDS(X22)
25900	CC	CALL LOOP(WDS(X22)+2,WDS(X),1,0,JY,ST)
26100	CC	K=X22
26200	CC194	N=K+1
26300	CC	WDS(N)=WDS(N+1)-JY
26400	CC	PWDS(K)=PWDS(N)-L
26500	CC	K=N
26600	CC	IF(K.LT.X)GO TO 194
26700	C  ABOVE RESHUFFLES POINTER ARRAYS. X=ITEM+1
26800	CC	ITEM=ITEM-1
26900	CC	IF(X22.GT.ITEM)X22=ITEM
27000	CC	J2=ITEM
27100	CC	ITEM=ITEM-1
27200	CC195	ST2=WDS(J2)
27300	CC271	CALL DPYNEW
27400	CC	END
27500	
27600	
27700	CF	SUBROUTINE DPYNEW
27800	CF	COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
27900	CF	CALL ACCPOG(1)
29800	CP14	KA=0
29900	CP3	KA=KA+1
30000	CP	IF(MLL.EQ.0)GO TO 15
30100	CP	K=K-2
30200	CP	MLL=MLL-1
30300	CP	IF(MLL.EQ.0)GO TO 10
30400	CP	GO TO 31
30500	CP15	TYPE 2,KA
30600	CP	ACCEPT 11,K,MLL,RSPC
30700	C  TYPE LAST NAME, NUMBER  FOR A SERIES, 2ND NUM FOR FIXED SPACE ".
30800	CP50	IF(K.EQ.' ')GO TO 10
30900	CP	IF(K.EQ.'99')GO TO 140
31000	C  99=BACKUP
31100	CP31	IF(LOOKD(K))GO TO 56
31200	C JUMP IF FILE FOUND
31300	CP	TYPE 55
31400	CP	GO TO 15
31500	CP55	FORMAT(' FILE NOT FOUND'/)
31600	CP11	FORMAT(A5,I,F)
31700	CP56	NMS(KA)=K
31800	CP	IF(MLL.EQ.0)GO TO 5
31900	CP	R8='Y'
32000	CP	IF(RSPC.NE.0)R8=RSPC
32100	CP	GO TO 21
32200	CP5	TYPE 8
32300	CP	ACCEPT FA5,R8
32400	CP	IF(R8.EQ.'99')GO TO 15
32500	CP	IF(R8.NE.'Y')R8=0
32600	CP	IF(R8.EQ.0)REREAD F78F,R8
32700	C  MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
32800	CP21	RMOV1(KA+1)=R8
32900	CP	RMOV2(KA)=R8
33000	CP	GO TO 3
33100	CP140	KA=KA-1
33200	CP	GO TO 15
33300	
33400	CP10	KB=KA-1
33500	CP	TYPE 9
33600	CP	ACCEPT F78F,RS
33700	CP	RSIZ=RS
33800	CP	IF(RSIZ.EQ.0)GO TO 5
33900	CP	IF(RSIZ.EQ.99)GO TO 5
34000	CP	KA=0
34100	
34200	CP1	IF(NAME.NE.0)GO TO 12
34300	CP	IF(KA.EQ.KB)CALL EXIT
34400	CP	NAME=NMS(KA+1)
34500	CP	TYPE 111,NAME
34600	CP	RETURN
34700	CP12	KA=KA+1
34800	CP	NAME=0
34900	C  'PL' = CALCOMP OUTPUT
35000	CP	R8=0
35100	CP	R2=RS
35200	CP	R3=RS
35300	CP	R7=0
35400	CP	R5=1
35500	CP	R6=1
35600	CP	IF(RMOV2(KA).NE.'Y')R7=RMOV2(KA)
35700	CP	IF(RMOV1(KA).NE.0)R5=0
35800	CP	IF(RMOV2(KA).NE.0)GO TO 277
35900	CP	IF(R7.EQ.0)RETURN
36000	CP277	R6=0
36100	CP2	FORMAT(' TYPE FILE NAME',I2,1X$)
36200	CP8	FORMAT(' MOVE UP AT END? ',$)
36300	CP9	FORMAT(' SIZE FACTOR? ',$)
36400	CP111	FORMAT(1XA5/)
36500	CP	END
36600	
36700	
36800		SUBROUTINE SAVIT
36900		IMPLICIT INTEGER(A-Q,S-Z)
37000		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
37100		COMMON/DL/X22,SAVER,NAME/POSI/STFF(8),JJ2,IPOS
37200		COMMON/SCM/V(78),ISCR,LCNT,IRSTF,LIST(200),REND
37300		1 /ALF/INP(72),ML/XRN/RN(2000)/DPY/ST(4000),WDS(250),MEDIT,IGO
37400		1 /STF/RSTFAC(8),RSTJC/PTR/PWDS(250),ITEM,L,I,IX
37500		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
37600		DIMENSION SV(128)
37700		EQUIVALENCE (INP2,INP(2)),(ST2,ST(2)),(SV,LIST)
37800	C  'SAME' WILL REPEAT CURRENT NAME.  BLANK WILL USE FOR21.DAT.
37900		KX=-1
38000		K=0
38100	32	K=K+1
38200	C  THIS IS TO REPAIR DAMAGE DONE BY UNKNOWN BUGS!!!!
38300	33	L=PWDS(K)
38400		IA=PWDS(K+1)
38500		IB=RN(L)+3.+L
38600	C  THIS SHOULD BE NEW POINTER
38700		IF(IA-IB.EQ.0)GO TO 36
38800		IF(RN(IB)+3+IB.NE.PWDS(K+2))GO TO 38
38900		J=K+1
39000		PWDS(J)=IB
39100		TYPE 30,J
39200		GO TO 36
39300	30	FORMAT(' ?FIXED UP ITEM ',I4)
39400	38	IJ=IA-L
39500		DO 39 J2=K+1,ITEM
39600	39	PWDS(J2)=PWDS(J2+1)-IJ
39700		TYPE 31,K
39800		IF(KX.EQ.0)GO TO 50
39900		TYPE 21
40000		ACCEPT FA5,NAME
40100	C  ONLY DOES THIS ON THE FIRST ERROR
40200		GO TO 2
40300	50	J=RJ
40400		KX=0
40500		CALL LOOP(L,I,1,0,J,RN)
40600	C  REARRANGES DATA
40700		I=I-J
40800		ITEM=ITEM-1
40900		IF(ITEM.LE.K)GO TO 37
41000		GO TO 33
41100	C  GO BACK AND TRY AGAIN
41200	36	IF(IA.LE.L)GO TO 38
41300	C  JUMP IF PWDS IS OUT OF ORDER
41400		IF(K.LT.ITEM)GO TO 32
41500	31	FORMAT(' BAD ITEM--',I4/)
41600	37	KX=-1
41700		IF(SAVER.GE.0)GO TO 10
41800	CC101	REWIND 21
41900		SAVER=7
41950	101	CALL PUTFIL('TMP')
42000		GO TO 102
42100	3	FORMAT(' WRITE OVER ',A5,'.DMD?  ',$)
42102	CC3	FORMAT(' WRITE OVER ',A5,'.DAT?  ',$)
42200	1	FORMAT(I,24F)
42300	2	TYPE 3,NAME
42400		ACCEPT FA1,L
42500		IF(L.NE.'N')GO TO 4
42600	10	IF(INP2.NE.'M')GO TO 11
42700		INP2='B'
42800		GO TO 4
42805	11	L=NAME
42810		CALL FORMAT(NAME)
42820		IF(NAME.NE.' ')GO TO 40
42900		TYPE 21
43100		ACCEPT FA5,NAME
43150		IF(NAME.EQ.' ')GO TO 4
43200	C 99 WILL BACK UP.
43300		IF(NAME.NE.'99')GO TO 40
43400		NAME=L
43500		RETURN
43600	40	IF(NAME.NE.'SAME')GO TO 43
43700		NAME=L
43800		GO TO 4
43900	CC43	IF(LOOKD(NAME))GO TO 2
43902	43	IF(LOOKF(NAME))GO TO 2
44000	C  JUMP BACK IF FILE NAME ALREADY ON DSK
44100	4	IF(KX.EQ.0)GO TO 50
44200	CC	REWIND 21
44300		IF(NAME.NE.' ')GO TO 41
44350		NAME=L
44375		GO TO 101
44400	CC	CALL OFILE(21,NAME)
44450	41	CALL PUTFIL(NAME)
44500	CC	GO TO 42
44600	CC41	NAME=L
44700	42	IF(INP2.EQ.'D')GO TO 202
44800	C   SB=SAVE BIG;  SD=SAVE DPY ONLY; SM=SB WITH SAME NAME
44802	102	IRSTF=0
44803		IF(INP2.EQ.'B')IRSTF=-1
44805		JJ2=ITEM+2
44807		IPOS=I
44808	C WD CNTS
44810		CALL FASTOU(RSTFAC,128)
44815	C  INCLUDES STFF AND V ARRAYS
44820		CALL FASTOU(PWDS,JJ2)
44830		CALL FASTOU(RN,IPOS)
44840		IF(LCNT.GT.1)CALL FASTOU(LIST,LCNT)
44900	CC102	WRITE(21)ITEM,I
45000	CC	1,(PWDS(L),L=1,ITEM+1),(RN(L),L=1,I-1),ISCR,(V(L),L=1,ISCR),
45100	CC	1 LCNT,(LIST(L),L=1,LCNT),RSTFAC,STFF,SV
45200	C (SV) FOR FORTRAN READ BUG!!!!
45300	CC	IF(SAVER.GE.0)WRITE(21)RSTFAC,STFF,L
45400	C NOT USED WHEN SAVE IS AUTOMATIC.
45500	C  TAKE OUT ABOVE WHEN BUG IS SOMEDAY FIXED IN F4.
45600		IF(I.GT.2000)TYPE 20,I
45700	CC	IF(INP2.NE.'B')GO TO 1001
45710		IF(INP2.EQ.'B')CALL FASTOU(ST,4250)
45800	CC	WRITE(21)ST2,(ST(L),L=1,ST2+2),(WDS(L),L=1,ITEM+1)
45900	CC1001	END FILE 21
45950	1001	CALL FINFIL
46000		IF(INP(1).NE.'S')RETURN
46100		IF(NAME.EQ.' ')TYPE 5600
46200	C   GO BACK IF THE SAVER WROTE THE FILE
46300		RETURN
46400	20	FORMAT(' ****** TOO MUCH DATA TO PRINT - ',I4,'/2000')
46500	202	WRITE(21),ST2,(ST(L),L=1,ST2+2)
46600		GO TO 1001
46700	C   WRITES DPY BUFFER ONLY.
46800	5600	FORMAT(' DISPLAY SAVED IN ''TMP.DMD'''/)
46900	21	FORMAT(' FILE NAME?  '$)
47000		END
47100	
47200		SUBROUTINE LISTP(LST)
47300		IMPLICIT INTEGER(A-Q,S-Z)
47500		DIMENSION LST(13)
47600		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
47700		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),K,JY,X,Y
47800		COMMON /XRN/RN(2000) /PTR/PWDS(250),ITEM,L,I,IX
47900		EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(RJC,RJQ(1)),(RJD,RJQ(2))
48000	
48100		CALL NOZERO(R2)
48150		JC=RJC
48200		IF(JC.EQ.0)JC=ITEM
48300		JY=5
48350		JD=RJD
48400		IF(JD.NE.0)JY=3
48500		DO 6334 L=IFIX(R2),JC
48600		X=PWDS(L)
48700		Y=RN(X)+2+X
48800		X=X+1
48900		K=RN(X)
49000		IF(K.EQ.13)K=11
49100		IF(K.GE.11)K=K-1
49200		IF(K.GE.15)K=K-4
49300	6334	WRITE(JY,6333),L,LST(K),(RN(K),K=X,Y)
49500	C  P, N1, N2, N3  TYPES ITEM LIST. N1=1ST, N2=LAST, N3=TO LPT?
49800	C  LEAVE THIS HERE SO WRITE(JY, OF R IS POSSIBLE IN DDT
50000	63331	FORMAT(8F10.4)
50100	6333	FORMAT(I4,') ',A5,2F4.0,F8.3,F8.2,7F10.2)
50200		END